perm filename DPYIT.F4[MSS,LCS]3 blob sn#097589 filedate 1974-04-17 generic text, type T, neo UTF8
00100	C**** SUBRS LINES, RDRAW, UNPACK, GRIDS, SHIFT, SHIFTX, REPACK
00200		SUBROUTINE LINES(A,B,L)
00300		COMMON /RZ/RSZ,IPLT,RJB,CENTR
00400		COMMON /FL/C,D,NQ,RZ,IXRX,XGP,RXGP
00500		DATA XGP/1200.0/,RX/1.0/
00600		COMMON/MN/M,N
00700	C  SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
00800	23	IF(IPLT)GO TO 2
00900		M=A*RSZ
01000		N=B*RSZ
01100		IF(L.EQ.3)GO TO 1
01200		CALL AVECT(M,N)
01300		RETURN
01400	1	CALL AIVECT(M,N)
01500		RETURN
02100	CC	DIS=RSZ*1.7
02200	CC	RHT=RSZ*1.7
02300	2	IF(IXRX.EQ.0)GO TO 9
02400	CC	M=-B*RHT-BX+RXGP
02410		AX=-B*RSZ
02500		BX=RX*A*RSZ+XGP
02510	CC	N=RX*A*DIS+XGP+AX
02600		GO TO 8
02700	9	AX=A*RSZ
02800		BX=B*RSZ
02810	CC9	M=A*DIS+AX
02855	CC	N=B*RHT+BX
02900	8	X=.5
02918		IF(AX)X=-X
02936		Y=.5
02954		IF(BX)Y=-Y
02972	C  A AND B ARE FOR ROUND-OFF
02982		M=AX+X	
02986		N=BX+Y
02990		CALL PLOT(M,N,L)
03000		RETURN
03100		END
03200	
03300		SUBROUTINE RDRAW(I,JJ,IJ,RJB,CENTR)
03400	C   TO X,Y INTO ONE WORD
03500		DIMENSION IJ(1)
03600		COMMON/LL/L
03700		COMMON/ZN/SCLEF(200,2),DDD
03800		COMMON/MN/M,N
03900		DO 2 K=I,JJ
04000		CALL UNPACK(K,IA,IB,IJ)
04100		A=IA+RJB
04200		B=IB+CENTR
04300		IF(K.EQ.I.OR.L.GE.100000000)L=3
04400		CALL LINES(A,B,L)
04500		SCLEF(K,1)=M
04600	2	SCLEF(K,2)=N
04700		CALL DPYOUT(1)
04800		RETURN
04900		END
05000	
05100		SUBROUTINE UNPACK(K,M,N,I)
05200		COMMON/LL/L
05300	C  L IS FOR VIS. OR INVIS. LINES.
05400		DIMENSION I(1)
05600		N=I(K)
05700		L=0
05800		IF(N.LT.100000000)GO TO 2
05900		L=(N/100000000)*100000000
06000		N=N-L
06100	2	M=N/10000
06200		N=N-M*10000
06300		IF(M.GT.1000)M=1000-M
06400		IF(N.GT.1000)N=1000-N
06600		END
06700	
06800		SUBROUTINE GRIDS
06900		COMMON /RC/MCLEF(200),IST(4000)
07000		COMMON /RZ/RSZ,IPLT,RJB,CENTR
07100		CALL DPYSET(2,IST,200)
07200		CALL DPYBRT(3)
07300		RB=32
07400		RC=35
07500		RD=78
07600		RA=2
07700	CC	IF(IPLT.LT.-1)GO TO 333
07800	C  TO SKIP LINES
07900		DO 30 L=-34,78,4
08000		RZ=L
08100		RE=RZ+CENTR
08200		IF(L.NE.-2.AND.L.NE.18.AND.L.NE.38.AND.L.NE.58)GO TO 32
08300		RF=RE+1
08400		RG=RE+3
08500		CALL LINES(RJB-1.0,RG,3)
08600		CALL LINES(RJB+1.0,RF,2)
08700		CALL LINES(RJB+19.0,RG,3)
08800		CALL LINES(RJB+21.0,RF,2)
08900	32	XA=2
09000		XB=0
09100		IF(L.EQ.14.OR.L.EQ.42)XA=20
09200		IF(L.EQ.-2.OR.L.EQ.26.OR.L.EQ.54)XB=20
09300		CALL LINES(RJB-RA-XA,RE,3)
09400		CALL LINES(RJB+RB+XA,RE,2)
09500		CALL LINES(RJB+RB+XB,RE+2.0,3)
09600	30	CALL LINES(RJB-RA-XB,RE+2.0,2)
09700		DO 31 L=-2,32,4
09800		RZ=L
09900		RE=RZ+RJB
10000		CALL LINES(RE,CENTR-RC,3)
10100		CALL LINES(RE,CENTR+RD,2)
10200		CALL LINES(RE+2.0,CENTR+RD,3)
10300	31	CALL LINES(RE+2.0,CENTR-RC,2)
10400		CALL LINES(RJB-10.,CENTR-14.,3)
10500		CALL LINES(RJB,CENTR-14.,2)
10600		CALL LINES(RJB,CENTR-28.,3)
10700		CALL LINES(RJB-10.,CENTR-28.,2)
10800		CALL DPYOUT(2)
11000		END
11100	
11200		SUBROUTINE SHIFT
11300		COMMON /RC/MCLEF(200),IST(4000)
11400		COMMON/ED/K,NEXT,NN,NX,NY,J
11500		EQUIVALENCE(JJ,IST(1)),(KK,IST(2))
11600		COMMON/SH/H,V,SH,SV
11700		TYPE 1
11800		JJ=1
11900		KK=2
12000		ACCEPT 2,H,V,SH,SV
12100		IF(SH.EQ.0)SH=1
12200		IF(SV.EQ.0)SV=1
12300		CALL SHIFTX(MCLEF,JJ)
12600	1	FORMAT(' MOVE HORIZ, VERT., SIZE H, SIZE V'/)
12700	2	FORMAT(4F)
12800		END
12900	
13000		SUBROUTINE SHIFTX(I,L)
13100		DIMENSION I(1)
13200		COMMON/SH/H,V,SH,SV
13300		JJ=I(L)
13400	2	DO 1 K=L+1,JJ
13500		CALL UNPACK(K,M,N,I)
13600		M=H+M*SH
13700		N=V+N*SV
13800	1	CALL REPACK(K,M,N,I)
13900		IF(JJ.EQ.I(1))RETURN
14000		L=1+JJ
14100		JJ=I(L)
14200		GO TO 2
14300		END
14400	
14500		SUBROUTINE REPACK(K,M,N,I)
14600		COMMON/LL/L
14700		DIMENSION I(1)
14800		M=M*10000
14900		IF(M)M=10000000-M
15000		IF(N)N=1000-N
15100		M=M+L
15200		I(K)=M+N
15300		RETURN
15400		END